Option Explicit
dim selectType:selectType = 0	 ' 0 - ALL | 1 select
dim delta_dx:delta_dx = 0.1
dim global_dx:global_dx =0


sub InitDB()
	call dbDict.add("width",3)
	call dbDict.add("length",10)
end sub

sub UpdateDB(ntypeobj)
	select case ntypeobj
		case 0
			dbDict.item("width")=6
			dbDict.item("length")=16
		case 1
			dbDict.item("width")=6
			dbDict.item("length")=16
		case 2
			dbDict.item("width")=6
			dbDict.item("length")=20
	end select
end sub

'#######################################################
'#######################################################
'#######################################################	
Dim doc
Set doc = application.ActiveDocument
call GetUserLicence(doc)
dim dbDict
set dbDict = createobject("scripting.Dictionary")
dim ncount:ncount = 0
dim errcount:errcount = 0
main
msgbox "update component(s) = " & ncount & vbcrlf & "confict components(s) = " & round(errcount/8)
dbDict.removeall()
set dbDict = nothing

sub main()
	InitDB
	'TODO
	doc.currentunit = 2'th
	doc.unhighlightall	
	dim ntype:	ntype = 0 ' 0 -use extends | 1-use silkscreen rect
	dim cmps,cmp
	set cmps = doc.components(selectType)
	dim fab,fabs	
	dim po,pos
	dim xmin,xmax,ymin,ymax
	dim txmin,txmax,tymin,tymax
	dim cellname
	
	dim cmppin,cmppins
	for each cmp in cmps
		set po = nothing
		cellname = lcase(cmp.cellname)
		global_dx=0
		If InStr(cellname, "bga") > 0 or InStr(cellname, "csp") > 0 Then
			set fabs = cmp.FabricationLayerGfxs(2,0,cmp.side)
			'msgbox fabs.count
			for each fab in fabs				
				set pos = fab.Geometry	
				if pos.IsRect = true then					
					ntype = 1
					pos.LineWidth=6
					set po = fab.Geometry
				end if					
			next
			
			' get box
			select case ntype
				case 0 'use placebound
					
					xmin = ""
					xmax = ""
					ymin = ""
					ymax = ""					
					for each cmppin in cmppins
						txmin = cmppin.Extrema.MinX
						txmax = cmppin.Extrema.MaxX
						tymin = cmppin.Extrema.MinY
						tymax = cmppin.Extrema.MaxY	
						if xmin="" then
							xmin = txmin
							xmax = txmax
							ymin = tymin
							ymax = tymax
						else
							if txmin <xmin then xmin = txmin
							if txmax > xmax then xmax = txmax
							if tymin <ymin then ymin = tymin
							if tymax > ymax then ymax = tymax
						end if
					next
						
				case 1 'use rect
					xmin = po.RectMinX
					xmax = po.RectMaxX
					ymin = po.RectMinY
					ymax = po.RectMaxY
			end select				
			'msgbox(xmin & "," & ymin & vbCrlf & xmax & "," & ymax)
			
			' update db
			dim dx,dy
			dx = abs(xmax-xmin)
			dy = abs(ymax-ymin)
			
			'特殊情况
			dim recalc:recalc=false
			set cmppins = cmp.pins
			if cmppins.count=4 and dx<>dy then recalc =true
			if cmppins.count=9 and dx<>dy then recalc =true
			'if cmppins.count=16 and dx<>dy then recalc =true
			
			' 重新计算			
			if recalc=true then
				xmin = ""
				for each cmppin in cmppins
					txmin = cmppin.Extrema.MinX
					txmax = cmppin.Extrema.MaxX
					tymin = cmppin.Extrema.MinY
					tymax = cmppin.Extrema.MaxY	
					if xmin="" then
						xmin = txmin
						xmax = txmax
						ymin = tymin
						ymax = tymax
					else
						if txmin <xmin then xmin = txmin
						if txmax > xmax then xmax = txmax
						if tymin <ymin then ymin = tymin
						if tymax > ymax then ymax = tymax
					end if
				next	
			end if
			
			if dx=0 and dy=0 then 
			else
				dim isUpdate : isUpdate = -1
				'msgbox dx & vbcrlf & dy
				if dx>dy then
					isUpdate =GetDBparam(dy)
				else
					isUpdate =GetDBparam(dx)
				end if
				'msgbox isUpdate
				if isUpdate<>-1 then
					call UpdateDB(isUpdate)					
					call UpdateSilkScreenLine(cmp,xmin,ymin,xmax,ymax)
					ncount = ncount+1
					on error resume next
					' remove
					for each fab in fabs
						set pos = fab.Geometry 		
						if pos.IsRect = true then fab.delete				
					next
				end if				
			end if
		end if		
	next

	
end sub

function GetDBparam(ulenobj)
	dim ntype : ntype = -1	
	if ulenobj>24 and ulenobj<=60 then ntype =0
	if ulenobj>60 and ulenobj<=200 then ntype =1
	if ulenobj>200 then ntype =2
	GetDBparam = ntype
end function

sub UpdateSilkScreenLine(cmp,xmin,ymin,xmax,ymax)
	dim nlen :nlen = dbDict.item("length")
	dim x0,y0,x1,y1
	'@ point-1
	'=================
	x0 = xmin
	y0 = ymin
	'--to right
	x1 = x0+nlen
	y1 = y0
	call AddSilkScreenLine(cmp,x0,y0,x1,y1,10)	
	'--to up
	x1 = x0
	y1 = y0+nlen
	call AddSilkScreenLine(cmp,x0,y0,x1,y1,11)	

	'@ point-2
	'=================
	x0 = xmax
	y0 = ymin
	'--to left
	x1 = x0-nlen
	y1 = y0
	call AddSilkScreenLine(cmp,x0,y0,x1,y1,20)	
	'--to up
	x1 = x0
	y1 = y0+nlen
	call AddSilkScreenLine(cmp,x0,y0,x1,y1,21)

	
	'@ point-3
	'=================
	x0 = xmax
	y0 = ymax
	'--to left
	x1 = x0-nlen
	y1 = y0
	call AddSilkScreenLine(cmp,x0,y0,x1,y1,30)	
	'--to down
	x1 = x0
	y1 = y0-nlen
	call AddSilkScreenLine(cmp,x0,y0,x1,y1,31)
	
	'@ point-4
	'=================
	x0 = xmin
	y0 = ymax
	'--to left
	x1 = x0+nlen
	y1 = y0
	call AddSilkScreenLine(cmp,x0,y0,x1,y1,40)	
	'--to down
	x1 = x0
	y1 = y0-nlen
	call AddSilkScreenLine(cmp,x0,y0,x1,y1,41)
end sub

sub AddSilkScreenLine(compobj,x0,y0,x1,y1,loc)	
	
	dim ret
	dim nwidth:nwidth= dbDict.item("width")
	
	Dim pntsArr()
	ReDim pntsArr(1,1)
	Dim numPoints: numPoints =2
	
	pntsArr(0,0) = x0
	pntsArr(1,0) = y0
	pntsArr(0,1) = x1
	pntsArr(1,1) = y1
	'msgbox(x0 & "," & y0 & vbCrlf & x1 & "," & y1)
	
	dim cside :cside = 1
	if compobj.side <> 1 then cside = 512
	dim fabObj
	ret= OnCheckCross(compobj,x0,y0,x1,y1)	
	if ret = true then
		'msgbox loc & vbcrlf & global_dx & vbcrlf & global_dx
		'global_dx = global_dx + 1.0 + delta_dx
		errcount = errcount +1
		select case loc
			case 10 ' point-1-X
				pntsArr(0,0) = x0-global_dx
				pntsArr(1,0) = y0-global_dx
				pntsArr(0,1) = x1-global_dx
				pntsArr(1,1) = y1-global_dx
			case 11 ' point-1-Y
				pntsArr(0,0) = x0-global_dx
				pntsArr(1,0) = y0-global_dx
				pntsArr(0,1) = x1-global_dx
				pntsArr(1,1) = y1-global_dx
			case 20 ' point-2-X
				pntsArr(0,0) = x0+global_dx
				pntsArr(1,0) = y0-global_dx
				pntsArr(0,1) = x1+global_dx
				pntsArr(1,1) = y1-global_dx
			case 21 ' point-2-Y
				pntsArr(0,0) = x0+global_dx
				pntsArr(1,0) = y0-global_dx
				pntsArr(0,1) = x1+global_dx
				pntsArr(1,1) = y1-global_dx
			case 30 ' point-3-X
				pntsArr(0,0) = x0+global_dx
				pntsArr(1,0) = y0+global_dx
				pntsArr(0,1) = x1+global_dx
				pntsArr(1,1) = y1+global_dx
			case 31 ' point-3-Y
				pntsArr(0,0) = x0+global_dx
				pntsArr(1,0) = y0+global_dx
				pntsArr(0,1) = x1+global_dx
				pntsArr(1,1) = y1+global_dx
			case 40 ' point-4-X
				pntsArr(0,0) = x0-global_dx
				pntsArr(1,0) = y0+global_dx
				pntsArr(0,1) = x1-global_dx
				pntsArr(1,1) = y1+global_dx
			case 41 ' point-4-Y
				pntsArr(0,0) = x0-global_dx
				pntsArr(1,0) = y0+global_dx
				pntsArr(0,1) = x1-global_dx
				pntsArr(1,1) = y1+global_dx	
		end select		
	end if
	
	set fabObj = doc.PutFabricationLayerGfx(2,compobj.side,nwidth,numPoints,PntsArr,false,compobj,2)
end sub

function OnCheckCross(compobj,x0,y0,x1,y1)
	dim ismark:ismark = false
	dim nwidth:nwidth= dbDict.item("width")
	dx = 0.5*nwidth
	dim sellyr
	if compobj.side = 1 then
		sellyr = 1
	else
		sellyr = doc.layercount
	end if
	
	dx = dx + delta_dx
	
	dim xmin,ymin,xmax,ymax
	if x0 = x1 then
		if y1>y0 then
			xmin = x0-dx
			ymin = y0
			xmax = x1+dx
			ymax = y1
		else
			xmin = x1-dx
			ymin = y1
			xmax = x0+dx
			ymax = y0
		end if		
	else
		if x1>x0 then
			xmin = x0
			ymin = y0-dx
			xmax = x1
			ymax = y1+dx
		else
			xmin = x1
			ymin = y1-dx
			xmax = x0
			ymax = y0+dx
		end if	
	end if
	'msgbox(xmin & "," & ymin & vbCrlf & xmax & "," & ymax)
	
	dim layerObj,layerObjColl
	Set layerObj = application.Utility.NewLayerObject
    layerObj.ConductorLayer = sellyr
	Set layerObjColl = application.Utility.NewLayerObjects
    layerObjColl.Add layerObj
	
	doc.unselectall()
	dim obs,ob
	dim lpad,lpads
	dim lpad_po,lpad_pos
	dim tmpx
	dim dx :dx = abs(x1-x0)+delta_dx
	if dx = delta_dx then dx  = abs(y1-y0)+delta_dx
	Set obs = doc.Pick(xmin, ymin, xmax, ymax,-1,layerObjColl, false, true,0)	
	dim tmp_dx:tmp_dx=0
	dim tmp_name
	dim distance
	if obs.count>1 then 
		for each ob in obs
			'on error resume next
			if ob.Type=1 then 'pin					
				ob.selected = true	
				tmp_name = lcase(ob.name)
				if tmp_name<>"plane obstruct" then				
					set lpads = ob.pads
					for each lpad in lpads 							
						set lpad_pos = lpad.Geometries 
						for each lpad_po in lpad_pos
							ob.highlighted = true
							if global_dx= 0 then
								tmp_dx = 0.5*cdbl(nwidth)+ 0.5*(ob.Extrema.maxx-ob.Extrema.minx)+delta_dx+ 3.0 
								distance = PerpendicularDistanceFromCToAB(x0, y0, x1, y1, ob.positionX, ob.positionY)								
								global_dx = abs(tmp_dx-distance)
								'msgbox ob.name & vbcrlf & x0 & "," & y0  & vbcrlf &  x1& "," &  y1 & vbcrlf &  ob.positionX& "," &  ob.positionY & vbcrlf & vbcrlf & distance
								'msgbox ob.name & vbcrlf & tmp_dx & vbcrlf & distance & vbcrlf & global_dx
							end if							
						next
					next
				end if				
			end if
		next
	end if	
	
	dim pins
	set pins = doc.pins(1)
	if pins.count>0 then ismark = true
	
	OnCheckCross = ismark
end function

' 计算点C到AB两点连线的垂直最短距离
Function PerpendicularDistanceFromCToAB(xA, yA, xB, yB, xC, yC)
    ' 检查A和B是否是同一个点（无法形成直线）
    If xA = xB And yA = yB Then
        PerpendicularDistanceFromCToAB = Sqr((xC - xA)^2 + (yC - yA)^2)
        Exit Function
    End If
    
    ' 计算AB线段的长度
    Dim AB_length
    AB_length = Sqr((xB - xA)^2 + (yB - yA)^2)
    
    ' 使用叉积公式计算面积（绝对值的两倍）
    Dim area
    area = Abs((xB - xA)*(yC - yA) - (yB - yA)*(xC - xA))
    
    ' 距离 = 面积 / AB长度
    PerpendicularDistanceFromCToAB = area / AB_length
End Function

'#######################################################
'#######################################################
'#######################################################
' Function to validate document
Private Function ValidateServer(docObj)
    Dim key, licenseServer, licenseToken
    key = docObj.Validate(0)
    Set licenseServer = CreateObject("MGCPCBAutomationLicensing.Application")
    licenseToken = licenseServer.GetToken(key)
    Set licenseServer = nothing
    'On Error Resume Next
    Err.Clear
    docObj.Validate(licenseToken)
    If Err Then
        ValidateServer = 0    
    Else 
        ValidateServer = 1
    End If
End Function

sub GetUserLicence(docObj)

	If ValidateServer(docObj) = 0 Then
	    msgbox "Server validation failed."
	    exit sub
	End If
	
end sub